The Atari Compendium/The Atari Compendium (Toad Computers) (1994).iso/files/prgtools/langs/iconv8_l.arc/PROGS.ARC/ipp.icn

Text File | 1990-03-08 | 33.5 KB | 1,064 lines

############################################################################
#
#    Name:    ipp.icn
#
#    Title:    Icon preprocessor
#
#    Author:    Robert C. Wieland
#
#    Date:    December 22, 1989
#
############################################################################
#
#     Ipp is a preprocessor for the Icon language.  Ipp has many operations and
#  features that are unique to the Icon environment and should not be used as a
#  generic preprocessor (such as m4).  Ipp produces output which when written to
#  a file is designed to be the source for icont, the command processor for Icon
#  programs.
#
#  Ipp may be invoked from the command line as:
#
#    ipp [option  ...] [ifile [ofile]]
#
#     Two file names may be specified as arguments.  'ifile' and 'ofile' are
#  respectively the input and output files for the preprocessor.  By default
#  these are standard input and standard output.  If the output file is to be
#  specified while the input file should remain standard input a dash ('-')
#  should be given as 'ifile'.  For example, 'ipp - test' makes test the output
#  file while retaining standard input as the input file.
#
#     The following special names are predefined by ipp and may not be redefined
#  or undefined.  The name _LINE_ is defined as the line number (as an
#  integer) of the line of the source file currently processed.  The
#  name _FILE_ is defined as the name of the current source file (as a string).
#     If the source is standard input then it has the value 'stdin'.
#
#     Also predefined are names corresponding to the features supported by the
#  implementation of Icon at the location the preprocessor is run.  This allows
#  conditional translations using the 'if' commands, depending on what features
#  are available.  Given below is a list of the features on a 4.nbsd UNIX
#  implementation and the corresponding predefined names:
#
#      Feature                Name
#      -----------------------------------------------------
#      UNIX                UNIX
#      co-expressions            co_expressions
#      overflow checking        overflow_checking
#      direct execution        direct_execution
#      environment variables        environment_variables
#      error traceback            error_traceback
#      executable images        executable_images
#      string invocation        string_invocation
#      expandable regions        expandable_regions
#
#
#  Command-Line Options:
#  ---------------------
#
#    The following options to ipp are recognized:
#
#   -C        By default ipp strips Icon-style comments.  If this option
#         is specified all comments are passed along except those
#         found on ipp command lines (lines starting with  a '$'
#         command).
#
#   -D name
#   -D name=def    Allows the user to define a name on the command line instead
#         of using a $define command in a source file.  In the first
#         form the name is defined as '1'.  In the second form name is
#         defined as the text following the equal sign.  This is less
#         powerful than the $define command line since def can not
#         contain any white space (spaces or tabs).
#
#   -d depth    By default ipp allows include files to be nested to a depth
#         of ten.  This allows the preprocessor to detect infinitely
#         recursive include sequences.  If a different limit for the
#         nesting depth is needed it may changed by using this option
#         with an integer argument greater than zero. Also, if a file
#         is found to already be in a nested include sequence an
#         error message is written regardless of the limit.
#
#   -I dir    The following algorithm is normally used in searching for
#         $include files.  Names enclosed in <> are always expected to
#         in the /usr/icon/src directory.  On a UNIX system names enclosed
#         in "" are searched for by trying in order the directories
#         specified by the PATH environment variable.  On other systems
#         only the current directory is searched.  If the -I option is
#         given the directory specified is searched before the 'standard'
#         directories.  If this option is specified more than once the
#         directories specified are tried in the order that they appear
#         on the command line, then followed by the 'standard'
#          directories.
#
#
#  Preprocessor commands:
#  ----------------------
#
#     All ipp commands start with lines beginning with a '$'.  The name of the
#  command must immediately follow the '$'.  Any line beginning with a '$'
#  and not followed by a valid name will cause an error message to be sent
#  to standard error and termination of the preprocessor.  If the command
#  requires an argument then it must be separated from the command name by
#  white space (any number of spaces or tabs) otherwise the argument will be
#  considered part of the name and the result will likely produce an error.
#  In processing the #  commands ipp responds to exceptional conditions in one
#  of two ways.  It may produce a warning and continue processing or produce an
#  error message and terminate.  In both cases the message is sent to standard
#  error.  With the exception of error conditions encountered during the
#  processing of the command line, the messages normally include the name and
#  line number of the source file at the point the condition was
#  encountered.  Ipp was designed so that most exception conditions
#  encountered will produce errors and terminate.  This protects the user since
#  warnings could simply be overlooked or misinterpreted.
#
#     Many ipp command require names as arguments.  Names must begin with a
#  letter or an underscore, which may be followed by any number of letters,
#  underscores, and digits.  Icon-style comments may appear on ipp command
#  lines, however they must be separated from the normal end of the command by
#  white_space.  If any extraneous characters appear on a command line a
#  warning is issued.  This occurs when characters other than white-space or a
#  comment follow the normal end of a command.
#
#     The following commands are implemented:
#
#    $define:  This command may be used in one of two forms.  The first form
#           only allows simple textual substitution.  It would be invoked as
#          '$define name text'.  Subsequent occurrencegs of name are replaced
#          with text.  Name and text must be separated by one white space
#          character which is not considered to be part of the replacement
#          text.  Normally the replacement text ends at the end of the line.
#          The text however may be continued on the next line if the backslash
#          character '\' is the last character on the line.  If name occurs
#          in the replacement text an error message (recursive textual substi-
#          tution) is written.
#
#          The second form is '$define name(arg,...,arg) text' which defines
#          a macro with arguments.  There may be no white space between the
#          name and the '('.  Each occurrenceg of arg in the replacement text
#          is replaced by the formal arg specified when the macro is
#          encountered.   When a macro with arguments is expanded the arguments
#          are placed into the expanded replacement text unchanged.  After the
#          entire replacement text is expanded, ipp restarts its scan for names
#          to expand at the beginning of the newly formed replacement text.
#          As with the first form above, the replacement text may be continued
#          an following lines.  The replacement text starts immediately after
#          the ')'.
#          The names of arguments must comply with the convention for regular
#          names.  See the section below on Macro processing for more
#          information on the replacement process.
#
#    $undef:   Invoked as '$undef name'.   Removes the definition of name.  If
#          name is not a valid name or if name is one of the reserved names
#          _FILE_ or _LINE_ a message is issued.
#
#    $include: Invoked as '$include <filename>' or '$include "filename"'.  This
#          causes the preprocessor to make filename the new source until
#          end of file is reached upon which input is again taken from the
#          original source.  See the -I option above for more detail.
#
#    $dump:    This command, which has no arguments, causes the preprocessor to
#          write to standard error all names which are currently defined.
#          See '$ifdef' below for a definition of 'defined'.
#
#    $endif:   This command has no arguments and ends the section of lines begun
#          by a test command ($ifdef, $ifndef, or $if).  Each test command
#          must have a matching $endif.
#
#    $ifdef:   Invoked as 'ifdef name'.  The lines following this command appear
#          in the output only if the name given is defined.  'Defined' means
#            1.  The name is a predefined name and was not undefined using
#            $undef, or
#            2.  The name was defined using $define and has not been undefined
#            by an intervening $undef.
#
#    $ifndef:  Invoked as 'ifndef name'.  The lines following this command do not
#          appear in the ouput if the name is not defined.
#
#    $if:      Invoked as 'if constant-expression'.  Lines following this command
#          are processed only if the constant-expression produces a result.
#          The following arithmetic operators may be applied to integer
#          arguments: + - * / % ^
#
#          If an argument to one of the above operators is not an integer an
#          error is produced.
#
#             The following functions are provided: def(name), ndef(name)
#          This allows the utility of $ifdef and $ifndef in a $if command.
#          def produces a result if name is defined and ndef produces a
#          result if name is not defined.  There must not be any white space
#          between the name of the function and the '(' and also between the
#          name and the surrounding parentheses.
#
#             The following comparision operators may be used on integer
#           operands:
#
#          > >= = < <= ~=
#
#              Also provided are alternation (|) and conjunction(&).  The
#           following table lists all operators with regard to decreasing
#           precedence:
#
#          ^ (associates right to left)
#          * / %
#          + -
#               > >= = < <= ~=
#          |
#          &
#
#           The precedence of '|' and '&' are the same as the corresponding
#           Icon counterparts.  Parentheses may be used for grouping.
#
#    $else     This command has no arguments and reverses the notion of the test
#          command which matches this directive.  If the lines preceding this
#          command where ignored the lines following are processed, and vice
#          versa.
#
#  Macro Processing and Textual Substitution
#  -----------------------------------------
#     No substitution is performed on text inside single quotes (cset literals)
#  and double quotes (strings) when a line is processed.   The preprocessor will
#  detect unclosed cset literals or strings on a line and issue an error message
#  unless the underscore character is the last character on the line.  The
#  output from
#
#      $define foo bar
#      write("foo")
#
#  is
#
#       write("foo")
#
#     Unless the -C option is specified comments are stripped from the source.
#  Even if the option is given the text after the '#' is never expanded.
#
#     Macro formal parameters are recognized in $define bodies even inside cset
#  constants and strings.  The output from
#
#      $define test(a)        "a"
#      test(processed)
#
#  is the following sequence of characters: "processed".
#
#     Macros are not expanded while processing a $define or $undef.  Thus:
#
#      $define off invalid
#      $define bar off
#      $undef off
#      bar
#
#  produces off.  The name argument to $ifdef or $ifndef is also not expanded.
#
#     Mismatches between the number of formal and actual parameters in a macro
#  call are caught by ipp.  If the number of actual parameters is greater than
#  the number of formal parameters is error is produced.  If the number of
#  actual parameters is less than the number of formal parameters a warning is
#  issued and the missing actual parameters are turned into null strings.
#
############################################################################
#
#    The records and global variables used by ipp are described below:
#
#  Src_desc:        Record which holds the 'file descriptor' and name
#            of the corresponding file.  Used in a stack to keep
#                track of the source files when $includes are used.
#  Opt_rec         Record returned by the get_args() routine which returns
#            the options and arguments on the command line.  options
#            is a cset containing options that have no arguments.
#            pairs is a list of [option,  argument] pairs. ifile and
#            ofile are set if the input or output files have been
#            specified.
#  Defs_rec        Record stored in a table keyed by names.  Holds the
#            names of formal arguments, if any, and the replacement
#            text for that name.
#  Chars        Cset of all characters that may appear in the input.
#  Defs            The table holding the definition data for each name.
#  Depth        The maximum depth of the input source stack.
#  Ifile        Descriptor for the input file.
#  Ifile_name        Name of the input file.
#  Init_name_char     Cset of valid initial characters for names.
#  Line_no        The current line number.
#  Name_char        Cset of valid characters for names.
#  Non_name_char    The complement of the above cset.
#  Ofile        The descriptor of the output file.
#  Options        Cset of no-argument options specified on the command
#            line.
#  Path_list        List of directories to search in for "" include files.
#  Src_stack        The stack of input source records.
#  Std_include_paths    List of directories to search in for <> include files.
#  White_space        Cset for white-space characters.
#  TRUE            Defined as 1.
#
############################################################################

record Src_desc(fd, fname)
record Opt_rec(options, pairs, ifile, ofile)
record Defs_rec(arg_list, text)

global Chars, Defs, Depth, Ifile, Ifile_name, Init_name_char,
  Line_no, Name_char, Non_name_char, Ofile, Options, Path_list,
  Src_stack, Std_include_paths, White_space, TRUE

procedure main(arg_list)
  local cmd, line, source

  init(arg_list)

  repeat {
    while line := read(Ifile) do {
      Line_no +:= 1
      line ? {
    if tab(any('$')) then
      if cmd := tab(many(Chars)) then
        process_cmd(cmd)
      else
        error("Missing command")
    else
      write(Ofile, process_text(line))
        }
      }
    # Get new source
    close(Ifile)
    if source := pop(Src_stack) then {
      Ifile := source.fd
      Ifile_name := source.fname
      Line_no := 0
      }
    else  break
  }
end

procedure process_cmd(cmd)
  case cmd of {
    "dump":        dump()
    "define":        define()
    "undef":        undefine()
    "include":        include()
    "if":        if_cond()
    "ifdef":        ifdef()
    "ifndef":        ifndef()
    "else" | "endif":    error("No previous 'if' expression")
    "endif":        error("No previous 'if' expression")
    default:        error("Undefined command")
    }
  return
end

procedure init(arg_list)
  local s

  TRUE := 1
  Defs := table()
  Init_name_char := &letters ++ '_'
  Name_char := Init_name_char ++ &digits
  Non_name_char := ~Name_char
  White_space := ' \t\b'
  Chars := &ascii -- White_space
  Line_no := 0
  Depth := 10
  Std_include_paths := ["/usr/icon/src"]

  # Predefine features
  every s:= &features do {
    s[upto('  -', s)] := "_"
    Defs[s] := Defs_rec([], "1")
    }

  # Set path list for $include files given in ""
  Path_list := []
  if \Defs["UNIX"] then
    getenv("PATH") ? while put(Path_list, 1(tab(upto(':')), move(1)))
  else
    put(Path_list, "")

  process_options(arg_list)
end

procedure process_options(arg_list)
  local args, arg_opts, pair, simple_opts, tmp_list, value

  simple_opts := 'C'
  arg_opts := 'dDI'
  Src_stack := []

  args := get_args(arg_list, simple_opts, arg_opts)
  if \args.ifile then {
    (Ifile := open(args.ifile)) | stop("Can not open input file ", args.ifile)
    Ifile_name := args.ifile
    }
  else {
    Ifile := &input
    Ifile_name := "stdin"
    }
  if \args.ofile then
    (Ofile := open(args.ofile, "w")) | stop("Can not open output file",
      args.ofile)
  else
    Ofile := &output

  Options := args.options
  tmp_list := []
  every pair := !args.pairs do
    case pair[1] of {
      "D":    def_opt(pair[2])
      "d":    if (value := integer(pair[2])) > 0 then
          Depth := value
        else
          stop("Invalid argument for depth")
      "I":    push(tmp_list, pair[2])
    }
  Path_list := tmp_list ||| Path_list
end

procedure get_args(arg_list, simple_opts, arg_opts)
  local arg, ch, get_ofile, i, opts, queue
  opts := Opt_rec('', [])
  queue := []

  every arg := arg_list[i := 1 to *arg_list] do
    if arg == "-" then         # Next argument should be output file
      get_ofile := (i = *arg_list - 1) |
    stop("Invalid position of '-' argument")
    else if arg[1] == "-" then     # Get options
      every ch := !arg[2: 0] do
    if any(simple_opts, ch) then
      opts.options ++:= ch
    else if any(arg_opts, ch) then
      put(queue, ch)
    else
      stop("Invalid option - ", ch)
    else if ch := pop(queue) then     # Get argument for option
      push(opts.pairs, [ch, arg])
    else if \get_ofile then {     # Get output file
      opts.ofile := arg
      get_ofile := &null
      }
    else {            # Get input file
      opts.ifile := arg
      get_ofile := (i < *arg_list)
      }

  if \get_ofile | *queue ~= 0 then
    stop("Invalid number of arguments")

  return opts
end

# if_cond is the procedure for $if.  The procedure const_expr() which
# evaluates the constant expression may be found in expr.icn
#
# Procedure true_cond is invoked if the evaluation of a previous $if, $ifdef, or
# $ifndef causes subsequent lines to be processed.  Lines will be processed
# upto a $endif or a $else.  If $else is encountered, lines are skipped until
# the $endif matching the $else is encountered.
#
# Procedure false_cond is invoked if the evaluation of a previous $if, $ifdef,
# or $ifndef causes subsequent lines to be skipped.  Lines will be skipped
# upto a $endif or a $else.  If $else is encountered, lines are processed until
# the $endif matching the $else is encountered.
#
# If called with a 1, procedure skip_to skips over lines until a $endif is
# encountered.  If called with 2, it skips until either a $endif or $else is
# encountered.

procedure if_cond()
  local expr

  if expr := (tab(many(White_space)) & not pos(0) & tab(0)) then
    conditional(const_expr(expr))
  else
    error("Constant expression argument to 'if' missing")
end

procedure ifdef()
  local name

  if name := 2(tab(many(White_space)), tab(any(Init_name_char)) ||
    (tab(many(Name_char)) | ""), any(White_space) | pos(0)) then  {
    tab(many(White_space))
    if not(pos(0) | any('#')) then
      warning("Extraneous characters after argument to 'ifdef'")
    conditional(Defs[name])
    }
  else
    error("Argument to 'ifdef' is not a valid name")
end

procedure ifndef()
  local name

  if name := 2(tab(many(White_space)), tab(any(Init_name_char)) ||
    (tab(many(Name_char)) | ""), any(White_space) | pos(0)) then {
    tab(many(White_space))
    if not(pos(0) | any('#')) then
      warning("Extraneous characters after argument to 'ifndef'")
    if \Defs[name] then
      conditional(&null)
    else
      conditional(TRUE)
    }
  else
    error("Argument to 'ifndef' is not a valid name")
end

procedure conditional(flag)

  if \flag then
    true_cond()
  else
    false_cond()
end

procedure true_cond()
  local line

  while line := read(Ifile) & (Line_no +:= 1) do
    line ? {
      if tab(any('$')) then
        if tab(match("if")) then
          eval_cond()
        else if check_cmd("else") then {
      # Skip only until a $endif
      skip_to(1) |
            error("'endif' not encountered before end of file")
      return
      }
        else if check_cmd("endif") then
      return
    else
      process_cmd(tab(many(Chars))) | error("Undefined command")
      else
        write(Ofile, process_text(line))
      }

    error("'endif' not encountered before end of file")
end

procedure false_cond()
  local cmd, line

  # Skip to $else or $endif
  (cmd := skip_to(2)) | error("'endif' not encountered before end of file")
  if cmd == "endif" then
    return

  while line := read(Ifile) & (Line_no +:= 1) do
    line ? {
      if tab(any('$')) then
    if check_cmd("endif") then
      return
    else if tab(match("if")) then
      eval_cond()
    else
      process_cmd(tab(many(Chars))) | error("Undefined command")
      else
        write(Ofile, process_text(line))
      }
  error("'endif' not encountered before end of file")
end

procedure eval_cond()
    if tab(match("def")) & (any(White_space) | pos(0)) then
      ifdef()
    else if tab(match("ndef")) & (any(White_space) | pos(0)) then
      ifndef()
    else if any(White_space) | pos(0) then
      return const_expr(tab(0))
    else
      error("Undefined command")
end

procedure check_cmd(cmd)
  local s

  if (s := tab(match(cmd))) & (tab(many(White_space)) | pos(0)) then {
    if not(match("if", cmd) | pos(0) | any('#')) then
      warning("Extraneous characters after command")
    return s
    }
  else
    fail
end

procedure skip_to(n)
  local cmd, ifs, elses, line, s

  ifs := elses := 0
  while line := read(Ifile) & (Line_no +:= 1) do
    line ? {
      if tab(any('$')) then
    if cmd := (check_cmd("endif") | (n = 2 & check_cmd("else"))) then
      if ifs = elses = 0 then
        return cmd
      else if cmd == "endif" then {
        ifs -:= 1
        elses := 0
        }
      else if elses = 0 then
        if ifs > 0 then
          elses := 1
        else
          error("'$else' encountered before 'if'")
      else
        error("Previous '$else' not terminated by 'endif'")
    else if check_cmd("endif") then {
      ifs -:= 1
      elses := 0
      }
        else if check_cmd("if" | "ifdef" | "ifndef") then
          ifs +:= 1
        else         # $else
          if elses = 0 then
            if ifs > 0 then
              elses := 1
            else
              error("'$else' encountered before 'if'")
       else
         error("Previous '$else' not terminated by 'endif'")
   }
end

procedure define()
  local args, name, text

  if name := 2(tab(many(White_space)), tab(any(Init_name_char)) ||
    (tab(many(Name_char)) | ""), any(White_space | '(') | pos(0)) then {
    if name == ("_LINE_" | "_FILE_") then
      error(name, " is a reserved name and can not be redefined")

    if tab(any('(')) then {         # A macro
      if not upto(')') then
    error("Missing ')' in macro definition")
      args := get_formals()
      text := get_text(TRUE)
      }
    else {
      args := []
      text := get_text()
      }

    if \Defs[name] then
      warning(name, " redefined")
    Defs[name] := Defs_rec(args, text)
    }
  else
    error("Illegal or missing name in define")
end

procedure get_text(flag)
  local get_cont, text, line

  if \flag then
    text := (tab(many(White_space)) | "") || tab(0)
  else
    text := (tab(any(White_space)) & tab(0)) | ""
  if text[-1] == "\\" then {
    get_cont := TRUE
    text[-1] := ""
    while line := read(Ifile) do {
    Line_no +:= 1
      text ||:= line
      if text[-1] == "\\" then
        text[-1] := ""
      else {
        get_cont := &null
        break
        }
      }
    }
  if \get_cont then
    error("Continuation line not found before end of file")
  return text
end

procedure get_formals()
  local arg, args, ch, edited

  args := []
  while arg := 1(tab(upto(',)')), ch := move(1)) do {
    if edited := (arg ? 2(tab(many(White_space)) | TRUE,
      tab(any(Init_name_char)) || (tab(many(Name_char)) | ""),
      tab(many(White_space)) | pos(0))) then
        put(args, edited)
    else if arg == "" then
      return [""]
    else
      error("Invalid formal argument in macro definition")
    if ch == ")" then
      break
    }
  return args
end

procedure undefine()
  local name

  if name := (tab(many(White_space)) & tab(many(Chars))) then {
    tab(many(White_space))
    if not(pos(0) | any('#')) then
      warning("Extraneous characters after argument to undef")
    if not(name ? (tab(any(Init_name_char)), (tab(many(Name_char)) | ""),
      pos(0))) then
      warning("Argument to undef is not a valid name")
    if name == ("_LINE_" | "_FILE_") then
      error(name, " is a reserved name that can not be undefined")
    \Defs[name] := &null
    }
  else
    error("Name missing in undefine")
end

procedure process_text(line)
  local add, entry, new, position, s, token
  static in_string, in_cset

  new :=  ""
  while *line > 0 do {
    add := ""
    line ? {
      if \in_string then {
    if new ||:= (tab(upto('"')) || move(1)) then
      in_string := &null
    else {
      new ||:= tab(0)
      if line[-1] ~== "_" then {
        in_string := &null
        warning("Unclosed double quote")
        }
      }
        }
      if \in_cset then {
    if new ||:= (tab(upto('\'')) || move(1)) then
      in_cset := &null
    else {
      new ||:= tab(0)
      if line[-1] ~== "_" then {
        in_cset := &null
        warning("Unclosed single quote")
        }
      }
    }

      new ||:= tab(many(White_space))
      if token := tab(many(Name_char) | any(Non_name_char)) then {
    if token == "\"" then { # Process string
      new ||:= "\""
          if \in_string then
        in_string := &null
      else {
        in_string := TRUE
        if pos(0) then {
          warning("Unclosed double quote")
          in_string := &null
          }
        }
      add ||:= tab(0)
      }
    else if token == "'" then { # Process cset literal
      new ||:= "'"
          if \in_cset then
        in_cset := &null
      else {
        in_cset := TRUE
        if pos(0) then {
          warning("Unclosed single quote")
          in_cset := &null
          }
        }
      add ||:= tab(0)
      }
    else if token == "#" then {
          if any(Options, "C") then
            new ||:= token || tab(0)
          else
        (new ||:= (token ? tab(upto('#')))) & tab(0)
      }
    else if token == "_LINE_" then
      new ||:= string(Line_no)
    else if token == "_FILE_" then
      new ||:= Ifile_name
        else if /(entry := Defs[token]) then
        new ||:= token
    else if *entry.arg_list = 0 then
      if in_text(token, entry.text) then
        error("Recursive textual substitution")
      else
        add := entry.text
    else if *entry.arg_list = 1 & entry.arg_list[1] == "" then {
       if move(2) == "()" then
         add := entry.text
       else
             error(token, ":  Invalid macro call")
       }
        else {  # Macro with arguments
      s := tab(bal(White_space, '(', ')') | 0)
      if not any('(', s) then
            error(token, ":  Incomplete macro call")
          add := process_macro(token, entry, s)
      }
        }
      position := &pos
      }
    line := add || line[position: 0]
    }
  return new
end

procedure process_macro(name, entry, s)
  local arg, args, new_entry, news, token

  s ? {
    args := []
    if tab(any('(')) then {
      repeat {
    arg := tab(many(White_space)) | ""
        if token := tab(many(Chars -- '(,)')) then {
          if /(new_entry := Defs[token]) then
          arg ||:= token
      else if *new_entry.arg_list = 0 then
        arg ||:= new_entry.text
          else {  # Macro with arguments
        if news := tab(bal(' \t\b,)', '(', ')')) then
              arg ||:= process_macro(token, new_entry, news)
        else
              error(token, ":  Error in arguments to macro call")
        }
      } # if
    else if not any(',)') then
          error(name, ":  Incomplete macro call")
    arg ||:= tab(many(White_space))
        put(args, arg)
    if any(')') then
      break
    move(1)
        } # repeat
        if *args > *entry.arg_list then
          error(name, ":  Too many arguments in macro call")
    else if *args < *entry.arg_list then
          warning(name, ":  Missing arguments in macro call")
        return macro_call(entry, args)
      } # if
    }
end

procedure macro_call(entry, args)
  local i, map, result, token, x, y

  x := create !entry.arg_list
  y := create !args
  map := table()
  while map[@x] := @y | ""

  entry.text ? {
    result := tab(many(Non_name_char)) | ""
    while token := tab(many(Name_char)) do {
      result ||:= \map[token] | token
      result ||:= tab(many(Non_name_char))
      }
    }
  return result
end

procedure in_text(name, text)
  text ?
    return (pos(1) & tab(match(name)) & (upto(Non_name_char) | pos(0))) |
      (tab(find(name)) & move(-1) & tab(any(Non_name_char)) & move(*name) &
    any(Non_name_char) | pos(0))
end

# In order to simplify the evaluation the three relational operators that
# are longer than one character (<= ~= >=) are replaced by one character
# 'aliases'.
#
# One problem with eval_expr() is that the idea of failure as opposed to
# returning some special value can not be used.  For example if def(UNIX)
# fails eval_expr() would try to convert it to an integer as its next step.
# We would only want func() to fail if the argument is not a valid function,
# not if the function is valid and the call fails.  'Failure' is therefore
# represented by &null.

procedure const_expr(expr)
  local new, temp

  new := ""
  every new ||:= (" " ~== !expr)
  while new[find(">=", new) +: 2] := "\200"
  while new[find("<=", new) +: 2] := "\201"
  while new[find("~=", new) +: 2] := "\202"
  return \eval_expr(new) | &null

end

procedure eval_expr(expr)
  while expr ?:= 2(="(", tab(bal(')')), pos(-1))
  return lassoc(expr, '&') | lassoc(expr, '|') |
    lassoc(expr, '<=>\200\201\202' | '+-' | '*/%') | rassoc(expr, '^') |
    func(expr) | integer(process_text(expr)) | error(expr, " :  Integer expected")
end

procedure lassoc(expr, op)
  local j

  expr ? {
    every j := bal(op)
    return eval(tab(\j), move(1), tab(0))
    }
end

procedure rassoc(expr, op)
  return expr ? eval(tab(bal(op)), move(1), tab(0))
end

procedure func(expr)
  local name, arg

  expr ? {
    (name := tab(upto('(')),
    arg := (move(1) & tab(upto(')')))) | fail
    }
  if \name == ("def" | "ndef") then
    return name(arg)
  else
    error("Invalid function name")
end

procedure eval(arg1, op, arg2)
  arg1 := process_text(\eval_expr(arg1)) | &null
  arg2 := process_text(\eval_expr(arg2)) | &null
  if (op ~== "&") & (op ~== "|") then
    (integer(arg1) & integer(arg2)) |
      error(map(op), " :  Arguments must be integers")
  return case op of {
    "+":    arg1 + arg2
    "-":    arg1 - arg2
    "*":    arg1 * arg2
    "/":    arg1 / arg2
    "%":    arg1 % arg2
    "^":    arg1 ^ arg2
    ">":     arg1 > arg2
    "=":    arg1 = arg2
    "<":    arg1 < arg2
    "\200":    arg1 >= arg2
    "\201":    arg1 <= arg2
    "\202":    arg1 ~= arg2
    "|":    alt(arg1, arg2)
    "&":    conjunction(arg1, arg2)
    }
end

procedure def(name)
  if \Defs[name] then
    return ""
  else
    return &null
end

procedure ndef(name)
  if \Defs[name] then
    return &null
  else
    return ""
end

procedure alt(x, y)
  if \x then
    return x
  else if \y then
    return y
  else
    return &null
end

procedure conjunction(x, y)
  if \x & \y then
    return y
  else
    return &null
end

procedure map(op)
  return case op of {
    "\200":     ">="
    "\201":     "<="
    "\202":     "~="
    default:     op
    }
end

procedure dump()
  tab(many(White_space))
  if not(pos(0) | any('#')) then
    warning("Extraneous characters after dump command")
  every write(&errout, (!sort(Defs))[1])
end

procedure include()
  local ch, fname
  static fname_chars

  initial fname_chars := Chars -- '<>"'

  if fname := 3(tab(many(White_space)), (tab(any('"')) & (ch := "\"")) |
    (tab(any('<')) & (ch := ">")), tab(many(fname_chars)),
    tab(any('>"')) == ch, tab(many(White_space)) | pos(0)) then {
    if not(pos(0) | any('#')) then
      warning("Extraneous characters after include file name")
    if ch == ">" then
      find_file(fname, Std_include_paths)
    else
      find_file(fname, Path_list)
    }
  else
    error("Missing or invalid include file name")
end

procedure find_file(fname, path_list)
  local ifile, ifname, path

  every path := !path_list do {
    if path == ("" | ".") then
      ifname := fname
    else
      ifname := path || "/" || fname
    if ifile := open(ifname) then {
      if *Src_stack >= Depth then {
    close(ifile)
        error("Possibly infinitely recursive file inclusion")
    }
      if ifname == (Ifile_name | (!Src_stack).fname) then
        error("Infinitely recursive file inclusion")
      push(Src_stack, Src_desc(Ifile, Ifile_name))
      Ifile := ifile
      Ifile_name := ifname
      Line_no := 0
      return
      }
    }
    error("Can not open include file ", fname)
end

procedure def_opt(s)
  local name, text, Name

  s ? {
    name := tab(upto('=')) | tab(0)
    text := (move(1) & tab(0)) | "1"
    }
  if name == ("_LINE_" | "_FILE_") then
    error(name, " is a reserved name and can not be redefined by the -D option")
  if name ~==:= (tab(any(Init_name_char)) & tab(many(Name_char)) & pos(0)) then
    error(name, " :  Illegal name argument to -D option")
  if \Defs[Name] then
    warning(name, " : redefined by -D option")
  Defs[name] := Defs_rec([], text)
end

procedure warning(s1, s2)
  s1 ||:= \s2
  write(&errout, Ifile_name, ":  ", Line_no, ":  ", "Warning  " || s1)
end

procedure error(s1, s2)
  s1 ||:= \s2
  stop(Ifile_name, ":  ", Line_no, ":  ", "Error  " || s1)
end